home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Intro_to_T2013918162006.psc / Intro to Texture Mapping / SurfaceGDI.cls < prev    next >
Text File  |  2006-07-10  |  3KB  |  109 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "SurfaceGDI"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14.  
  15. ' SurfaceGDI
  16. ' By: Hou Xiong
  17. '
  18. ' Simplifies gdi functions.
  19. ' If you decide to include these classes in
  20. ' your projects, please give me some credit.
  21.  
  22. Option Explicit
  23.  
  24. Public hDC As Long
  25. Public hBMP As Long
  26. Public hDib As Long
  27. Public width As Long
  28. Public height As Long
  29.  
  30. Private lBits() As Long
  31. Private bBits() As RGBQUAD
  32. Private sa As SAFEARRAY2D
  33. Private bitmapSize As Long
  34. Public widthBytes As Long
  35.  
  36. Public Sub InitSurface()
  37.         With sa
  38.             .cbElements = 4
  39.             .cDims = 2
  40.             .Bounds(0).lLbound = 0
  41.             .Bounds(0).cElements = height
  42.             .Bounds(1).lLbound = 0
  43.             .Bounds(1).cElements = width
  44.             .pvData = hDib
  45.         End With
  46.         
  47.         CopyMemory ByVal VarPtrArray(lBits()), VarPtr(sa), 4
  48.         CopyMemory ByVal VarPtrArray(bBits()), VarPtr(sa), 4
  49.         
  50.         bitmapSize = width * height * 4
  51.         widthBytes = width * 4
  52. End Sub
  53.  
  54. Public Function GetPixel(ByVal x As Long, ByVal y As Long) As Long
  55.     If (x >= 0) And (x < width) And (y >= 0) And (y < height) Then
  56.         GetPixel = lBits(x, y)
  57.     Else
  58.         GetPixel = -1
  59.     End If
  60. End Function
  61.  
  62. Public Sub SetPixel(ByVal x As Long, ByVal y As Long, ByVal Color As Long)
  63.     If (x >= 0) And (x < width) And (y >= 0) And (y < height) Then
  64.         lBits(x, y) = Color
  65.     End If
  66. End Sub
  67.  
  68. Public Sub FlipBuffer(ByVal hDC As Long)
  69.     BitBlt hDC, 0, 0, width, height, Me.hDC, 0, 0, vbSrcCopy
  70. End Sub
  71.  
  72. Public Sub Clear()
  73.     ZeroMemory lBits(0, 0), bitmapSize
  74. End Sub
  75.  
  76. Public Function MakeLongPointer(Pixels() As Long) As Boolean
  77.     If hDib = 0 Then Exit Function
  78.     CopyMemory ByVal VarPtrArray(Pixels()), VarPtr(sa), 4
  79.     MakeLongPointer = True
  80. End Function
  81.  
  82. Public Function MakeRGBPointer(ByVal lPixels As Long) As Boolean
  83.     If hDib = 0 Then Exit Function
  84.     CopyMemory ByVal lPixels, VarPtr(sa), 4
  85.     MakeRGBPointer = True
  86. End Function
  87.  
  88. Public Sub DeleteSurface()
  89.     If hDC = 0 Then Exit Sub
  90.     
  91.     CopyMemory ByVal VarPtrArray(lBits()), 0&, 4
  92.     CopyMemory ByVal VarPtrArray(bBits()), 0&, 4
  93.     
  94.     DeleteObject hBMP
  95.     DeleteDC hDC
  96.     
  97.     hDC = 0
  98.     hBMP = 0
  99.     hDib = 0
  100.     width = 0
  101.     height = 0
  102.     bitmapSize = 0
  103.     widthBytes = 0
  104. End Sub
  105.  
  106. Private Sub Class_Terminate()
  107.     DeleteSurface
  108. End Sub
  109.